home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_perl.idb / usr / freeware / lib / perl5 / 5.00502 / B / Lint.pm.z / Lint.pm
Encoding:
Perl POD Document  |  1998-10-28  |  9.1 KB  |  368 lines
  1. package B::Lint;
  2.  
  3. =head1 NAME
  4.  
  5. B::Lint - Perl lint
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. perl -MO=Lint[,OPTIONS] foo.pl
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. The B::Lint module is equivalent to an extended version of the B<-w>
  14. option of B<perl>. It is named after the program B<lint> which carries
  15. out a similar process for C programs.
  16.  
  17. =head1 OPTIONS AND LINT CHECKS
  18.  
  19. Option words are separated by commas (not whitespace) and follow the
  20. usual conventions of compiler backend options. Following any options
  21. (indicated by a leading B<->) come lint check arguments. Each such
  22. argument (apart from the special B<all> and B<none> options) is a
  23. word representing one possible lint check (turning on that check) or
  24. is B<no-foo> (turning off that check). Before processing the check
  25. arguments, a standard list of checks is turned on. Later options
  26. override earlier ones. Available options are:
  27.  
  28. =over 8
  29.  
  30. =item B<context>
  31.  
  32. Produces a warning whenever an array is used in an implicit scalar
  33. context. For example, both of the lines
  34.  
  35.     $foo = length(@bar);
  36.     $foo = @bar;
  37. will elicit a warning. Using an explicit B<scalar()> silences the
  38. warning. For example,
  39.  
  40.     $foo = scalar(@bar);
  41.  
  42. =item B<implicit-read> and B<implicit-write>
  43.  
  44. These options produce a warning whenever an operation implicitly
  45. reads or (respectively) writes to one of Perl's special variables.
  46. For example, B<implicit-read> will warn about these:
  47.  
  48.     /foo/;
  49.  
  50. and B<implicit-write> will warn about these:
  51.  
  52.     s/foo/bar/;
  53.  
  54. Both B<implicit-read> and B<implicit-write> warn about this:
  55.  
  56.     for (@a) { ... }
  57.  
  58. =item B<dollar-underscore>
  59.  
  60. This option warns whenever $_ is used either explicitly anywhere or
  61. as the implicit argument of a B<print> statement.
  62.  
  63. =item B<private-names>
  64.  
  65. This option warns on each use of any variable, subroutine or
  66. method name that lives in a non-current package but begins with
  67. an underscore ("_"). Warnings aren't issued for the special case
  68. of the single character name "_" by itself (e.g. $_ and @_).
  69.  
  70. =item B<undefined-subs>
  71.  
  72. This option warns whenever an undefined subroutine is invoked.
  73. This option will only catch explicitly invoked subroutines such
  74. as C<foo()> and not indirect invocations such as C<&$subref()>
  75. or C<$obj-E<gt>meth()>. Note that some programs or modules delay
  76. definition of subs until runtime by means of the AUTOLOAD
  77. mechanism.
  78.  
  79. =item B<regexp-variables>
  80.  
  81. This option warns whenever one of the regexp variables $', $& or
  82. $' is used. Any occurrence of any of these variables in your
  83. program can slow your whole program down. See L<perlre> for
  84. details.
  85.  
  86. =item B<all>
  87.  
  88. Turn all warnings on.
  89.  
  90. =item B<none>
  91.  
  92. Turn all warnings off.
  93.  
  94. =back
  95.  
  96. =head1 NON LINT-CHECK OPTIONS
  97.  
  98. =over 8
  99.  
  100. =item B<-u Package>
  101.  
  102. Normally, Lint only checks the main code of the program together
  103. with all subs defined in package main. The B<-u> option lets you
  104. include other package names whose subs are then checked by Lint.
  105.  
  106. =back
  107.  
  108. =head1 BUGS
  109.  
  110. This is only a very preliminary version.
  111.  
  112. =head1 AUTHOR
  113.  
  114. Malcolm Beattie, mbeattie@sable.ox.ac.uk.
  115.  
  116. =cut
  117.  
  118. use strict;
  119. use B qw(walkoptree_slow main_root walksymtable svref_2object parents);
  120.  
  121. # Constants (should probably be elsewhere)
  122. sub G_ARRAY () { 1 }
  123. sub OPf_LIST () { 1 }
  124. sub OPf_KNOW () { 2 }
  125. sub OPf_STACKED () { 64 }
  126.  
  127. my $file = "unknown";        # shadows current filename
  128. my $line = 0;            # shadows current line number
  129. my $curstash = "main";        # shadows current stash
  130.  
  131. # Lint checks
  132. my %check;
  133. my %implies_ok_context;
  134. BEGIN {
  135.     map($implies_ok_context{$_}++,
  136.     qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
  137.        pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
  138. }
  139.  
  140. # Lint checks turned on by default
  141. my @default_checks = qw(context);
  142.  
  143. my %valid_check;
  144. # All valid checks
  145. BEGIN {
  146.     map($valid_check{$_}++,
  147.     qw(context implicit_read implicit_write dollar_underscore
  148.        private_names undefined_subs regexp_variables));
  149. }
  150.  
  151. # Debugging options
  152. my ($debug_op);
  153.  
  154. my %done_cv;        # used to mark which subs have already been linted
  155. my @extra_packages;    # Lint checks mainline code and all subs which are
  156.             # in main:: or in one of these packages.
  157.  
  158. sub warning {
  159.     my $format = (@_ < 2) ? "%s" : shift;
  160.     warn sprintf("$format at %s line %d\n", @_, $file, $line);
  161. }
  162.  
  163. # This gimme can't cope with context that's only determined
  164. # at runtime via dowantarray().
  165. sub gimme {
  166.     my $op = shift;
  167.     my $flags = $op->flags;
  168.     if ($flags & OPf_KNOW) {
  169.     return(($flags & OPf_LIST) ? 1 : 0);
  170.     }
  171.     return undef;
  172. }
  173.  
  174. sub B::OP::lint {}
  175.  
  176. sub B::COP::lint {
  177.     my $op = shift;
  178.     if ($op->ppaddr eq "pp_nextstate") {
  179.     $file = $op->filegv->SV->PV;
  180.     $line = $op->line;
  181.     $curstash = $op->stash->NAME;
  182.     }
  183. }
  184.  
  185. sub B::UNOP::lint {
  186.     my $op = shift;
  187.     my $ppaddr = $op->ppaddr;
  188.     if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
  189.     my $parent = parents->[0];
  190.     my $pname = $parent->ppaddr;
  191.     return if gimme($op) || $implies_ok_context{$pname};
  192.     # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
  193.     # null out the parent so we have to check for a parent of pp_null and
  194.     # a grandparent of pp_enteriter or pp_delete
  195.     if ($pname eq "pp_null") {
  196.         my $gpname = parents->[1]->ppaddr;
  197.         return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete";
  198.     }
  199.     warning("Implicit scalar context for %s in %s",
  200.         $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
  201.     }
  202.     if ($check{private_names} && $ppaddr eq "pp_method") {
  203.     my $methop = $op->first;
  204.     if ($methop->ppaddr eq "pp_const") {
  205.         my $method = $methop->sv->PV;
  206.         if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
  207.         warning("Illegal reference to private method name $method");
  208.         }
  209.     }
  210.     }
  211. }
  212.  
  213. sub B::PMOP::lint {
  214.     my $op = shift;
  215.     if ($check{implicit_read}) {
  216.     my $ppaddr = $op->ppaddr;
  217.     if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
  218.         warning('Implicit match on $_');
  219.     }
  220.     }
  221.     if ($check{implicit_write}) {
  222.     my $ppaddr = $op->ppaddr;
  223.     if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
  224.         warning('Implicit substitution on $_');
  225.     }
  226.     }
  227. }
  228.  
  229. sub B::LOOP::lint {
  230.     my $op = shift;
  231.     if ($check{implicit_read} || $check{implicit_write}) {
  232.     my $ppaddr = $op->ppaddr;
  233.     if ($ppaddr eq "pp_enteriter") {
  234.         my $last = $op->last;
  235.         if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
  236.         warning('Implicit use of $_ in foreach');
  237.         }
  238.     }
  239.     }
  240. }
  241.  
  242. sub B::GVOP::lint {
  243.     my $op = shift;
  244.     if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
  245.     && $op->gv->NAME eq "_")
  246.     {
  247.     warning('Use of $_');
  248.     }
  249.     if ($check{private_names}) {
  250.     my $ppaddr = $op->ppaddr;
  251.     my $gv = $op->gv;
  252.     if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
  253.         && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
  254.     {
  255.         warning('Illegal reference to private name %s', $gv->NAME);
  256.     }
  257.     }
  258.     if ($check{undefined_subs}) {
  259.     if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
  260.         my $gv = $op->gv;
  261.         my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
  262.         no strict 'refs';
  263.         if (!defined(&$subname)) {
  264.         $subname =~ s/^main:://;
  265.         warning('Undefined subroutine %s called', $subname);
  266.         }
  267.     }
  268.     }
  269.     if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
  270.     my $name = $op->gv->NAME;
  271.     if ($name =~ /^[&'`]$/) {
  272.         warning('Use of regexp variable $%s', $name);
  273.     }
  274.     }
  275. }
  276.  
  277. sub B::GV::lintcv {
  278.     my $gv = shift;
  279.     my $cv = $gv->CV;
  280.     #warn sprintf("lintcv: %s::%s (done=%d)\n",
  281.     #         $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
  282.     return if !$$cv || $done_cv{$$cv}++;
  283.     my $root = $cv->ROOT;
  284.     #warn "    root = $root (0x$$root)\n";#debug
  285.     walkoptree_slow($root, "lint") if $$root;
  286. }
  287.  
  288. sub do_lint {
  289.     my %search_pack;
  290.     walkoptree_slow(main_root, "lint") if ${main_root()};
  291.     
  292.     # Now do subs in main
  293.     no strict qw(vars refs);
  294.     my $sym;
  295.     local(*glob);
  296.     while (($sym, *glob) = each %{"main::"}) {
  297.     #warn "Trying $sym\n";#debug
  298.     svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
  299.     }
  300.  
  301.     # Now do subs in non-main packages given by -u options
  302.     map { $search_pack{$_} = 1 } @extra_packages;
  303.     walksymtable(\%{"main::"}, "lintcv", sub {
  304.     my $package = shift;
  305.     $package =~ s/::$//;
  306.     #warn "Considering $package\n";#debug
  307.     return exists $search_pack{$package};
  308.     });
  309. }
  310.  
  311. sub compile {
  312.     my @options = @_;
  313.     my ($option, $opt, $arg);
  314.     # Turn on default lint checks
  315.     for $opt (@default_checks) {
  316.     $check{$opt} = 1;
  317.     }
  318.   OPTION:
  319.     while ($option = shift @options) {
  320.     if ($option =~ /^-(.)(.*)/) {
  321.         $opt = $1;
  322.         $arg = $2;
  323.     } else {
  324.         unshift @options, $option;
  325.         last OPTION;
  326.     }
  327.     if ($opt eq "-" && $arg eq "-") {
  328.         shift @options;
  329.         last OPTION;
  330.     } elsif ($opt eq "D") {
  331.             $arg ||= shift @options;
  332.         foreach $arg (split(//, $arg)) {
  333.         if ($arg eq "o") {
  334.             B->debug(1);
  335.         } elsif ($arg eq "O") {
  336.             $debug_op = 1;
  337.         }
  338.         }
  339.     } elsif ($opt eq "u") {
  340.         $arg ||= shift @options;
  341.         push(@extra_packages, $arg);
  342.     }
  343.     }
  344.     foreach $opt (@default_checks, @options) {
  345.     $opt =~ tr/-/_/;
  346.     if ($opt eq "all") {
  347.         %check = %valid_check;
  348.     }
  349.     elsif ($opt eq "none") {
  350.         %check = ();
  351.     }
  352.     else {
  353.         if ($opt =~ s/^no-//) {
  354.         $check{$opt} = 0;
  355.         }
  356.         else {
  357.         $check{$opt} = 1;
  358.         }
  359.         warn "No such check: $opt\n" unless defined $valid_check{$opt};
  360.     }
  361.     }
  362.     # Remaining arguments are things to check
  363.     
  364.     return \&do_lint;
  365. }
  366.  
  367. 1;
  368.